home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / smaltalk / st80_pr4.lha / st80_pre4 / MoDE / Menu-Shan.st < prev    next >
Text File  |  1993-07-24  |  29KB  |  973 lines
  1. SemanticObject subclass: #MenuCell
  2.     instanceVariableNames: 'selector receiver children parent selectability subMenuMode subMenuBackground activatingDirection '
  3.     classVariableNames: ''
  4.     poolDictionaries: ''
  5.     category: 'Menu-Shan'!
  6. MenuCell comment:
  7. 'MenuCells form a tree.  Each level of the tree is a menu.  The sum of them is a hierarchical menu.  Shan July 25, 1989'!
  8.  
  9.  
  10. !MenuCell methodsFor: 'hierarchy management'!
  11.  
  12. append: aMenuCell 
  13.     "Shan July 31, 1989"
  14.  
  15.     (aMenuCell isMemberOf: MMSMenu)
  16.         ifTrue: 
  17.             ["Get rid of the root and graft the children"
  18.             aMenuCell children do: [:each | self append: each].
  19.             aMenuCell children: nil.
  20.             aMenuCell mode release]
  21.         ifFalse: 
  22.             [children add: aMenuCell.
  23.             aMenuCell parent: self]!
  24.  
  25. isRoot
  26.     "Am I the root of the logic menu?  Shan July 27, 1989"
  27.  
  28.     ^parent isNil!
  29.  
  30. remove: aMenuCell 
  31.     "Shan July 25, 1989"
  32.  
  33.     children remove: aMenuCell ifAbsent: [].
  34.     aMenuCell parent: nil!
  35.  
  36. root
  37.     "Return the root of the tree structure.  The parent pointer is also  
  38.     used to point to the MMSPopUpMenu.  Shan July 25, 1989"
  39.  
  40.     parent isNil
  41.         ifTrue: [^self]
  42.         ifFalse: [^parent root]! !
  43.  
  44. !MenuCell methodsFor: 'access'!
  45.  
  46. activatingDirection
  47.     "This controlls the direction to which the subMenu is expanded.  It 
  48.     could be #up #down #left and #right.  Shan July 29, 1989"
  49.  
  50.     ^activatingDirection!
  51.  
  52. activatingDirection: aSymbol
  53.     "This controlls the direction to which the subMenu is expanded.  It 
  54.     could be #up #down #left and #right.  Shan July 29, 1989"
  55.  
  56.     activatingDirection _ aSymbol!
  57.  
  58. backgroundMode
  59.     "BackgroundMode is the mode that subMenu should be pasted to.  It is 
  60.     always three levels back from my mode.  The order is my mode, the 
  61.     mode group mode, and the background Mode.  Shan July 25, 1989"
  62.  
  63.     ^mode superMode superMode!
  64.  
  65. children
  66.     ^children!
  67.  
  68. children: c
  69.     children _ c!
  70.  
  71. parent
  72.     ^parent!
  73.  
  74. parent: p
  75.     parent _ p!
  76.  
  77. receiver
  78.     "Shan July 25, 1989"
  79.  
  80.     receiver notNil
  81.         ifTrue: [^receiver]
  82.         ifFalse: [^parent receiver]!
  83.  
  84. receiver: r
  85.     "Shan July 25, 1989"
  86.     
  87.     receiver _ r!
  88.  
  89. selectable
  90.     ^selectability!
  91.  
  92. selectable: aBool
  93.     selectability _ aBool!
  94.  
  95. selector
  96.     "Shan July 25, 1989"
  97.     
  98.     ^selector!
  99.  
  100. selector: s
  101.     "Shan July 25, 1989"
  102.     
  103.     selector _ s!
  104.  
  105. subMenuMode
  106.     "Shan July 25, 1989"
  107.  
  108.     ^subMenuMode!
  109.  
  110. subMenuMode: aModeGroup 
  111.     "aModeGroup is a mode that contains the formatted modes of the 
  112.     subMenu.  Shan July 25, 1989"
  113.  
  114.     subMenuMode _ aModeGroup!
  115.  
  116. text: aString 
  117.     "Shan July 30, 1989"
  118.  
  119.     mode displayObject relAdd: (aString asDisplayText offset: 2 @ 0).
  120.     mode resizeToFitDisplayObjectBy: 2 @ 0! !
  121.  
  122. !MenuCell methodsFor: 'controller-msg'!
  123.  
  124. action: e 
  125.     "Perform the action.  Shan July 25, 1989"
  126.  
  127.     mode controller deHighlight.
  128.     self root terminate: e.
  129.     children isEmpty ifTrue: ["No subMenu."
  130.         self receiver perform: selector]!
  131.  
  132. cursorEnters: e 
  133.     "If there is no subMenu, just highlight self.  Otherwise, show the        
  134.       subMenu.  Shan July 25, 1989"
  135.     "Check whether need to shrink other menu or not.  Shan July 27,    
  136.     1989"
  137.  
  138.     parent children do: [:each | each ~~ self ifTrue: [each shrinkSubMenus]].
  139.     mode controller highlight.
  140.     subMenuMode notNil ifTrue: [subMenuMode isVisible
  141.             ifFalse: 
  142.                 [activatingDirection = #right ifTrue: [self activateSubMenuAt: mode unclippedDisplayBox topRight].
  143.                 activatingDirection = #down ifTrue: [self activateSubMenuAt: mode unclippedDisplayBox bottomLeft].
  144.                 activatingDirection = #left ifTrue: [self activateSubMenuAt: mode unclippedDisplayBox topLeft - subMenuMode width].
  145.                 activatingDirection = #up ifTrue: [self activateSubMenuAt: mode unclippedDisplayBox topLeft - subMenuMode height]]]!
  146.  
  147. cursorLeaves: e 
  148.     "If there is no subMenu, just deHighlight self.  Otherwise, erase the     
  149.       subMenu.  If go into the subMenu, no operation.  Shan July 25, 
  150.     1989 "
  151.  
  152.     subMenuMode notNil
  153.         ifTrue: [(subMenuMode containsPoint: e previousOrigin)
  154.                 ifFalse: 
  155.                     ["For a leaveEvent, the previousOrigin actually stores 
  156.                     the current cursor position.  Shan July 26, 1989"
  157.                     self shrinkSubMenus]]
  158.         ifFalse: [mode controller deHighlight]! !
  159.  
  160. !MenuCell methodsFor: 'MMS-initializations'!
  161.  
  162. defaultMMSControllerClass
  163.     "Shan July 30, 1989"
  164.  
  165.     ^MenuCellController!
  166.  
  167. setUpAppearance
  168.     "Shan July 21, 1989"
  169.  
  170.     super setUpAppearance.
  171.     mode insideColor: Form white.
  172.     mode extent: 50@15.
  173.     mode highlightDispObj: #inverseHighlight!
  174.  
  175. setUpMode
  176.     "Shan July 25, 1989"
  177.  
  178.     | rs |
  179.     super setUpMode.
  180.     rs _ ResizeStyle new.
  181.     "rs extentY: #fixed.
  182.     rs cornerX: #fixed.
  183.     rs originX: #fixed."
  184.     mode resizeStyle: rs! !
  185.  
  186. !MenuCell methodsFor: 'initialize-release'!
  187.  
  188. initialize
  189.     "Shan July 25, 1989"
  190.     
  191.     super initialize.
  192.     children _ OrderedCollection new.
  193.     activatingDirection _ #right! !
  194.  
  195. !MenuCell methodsFor: 'private'!
  196.  
  197. restoreSubMenuBackground
  198.     "Shan July 28, 1989"
  199.  
  200.     subMenuBackground display.
  201.     subMenuBackground _ nil!
  202.  
  203. selector: s text: aString 
  204.     "This is for the most common text menu.  Other convenient messages 
  205.     can be added to make creating a MenuCell easy.  Shan July 25, 
  206.     1989 "
  207.  
  208.     selector _ s.
  209.     self text: aString!
  210.  
  211. storeSubMenuBackground
  212.     "Shan July 28, 1989"
  213.  
  214.     subMenuBackground _ (Form fromDisplay: subMenuMode displayBox)
  215.                 offset: subMenuMode displayBox origin! !
  216.  
  217. !MenuCell methodsFor: 'subMenu'!
  218.  
  219. activateSubMenuAt: p 
  220.     "Shan July 28, 1989"
  221.  
  222.     | delta enteredItemMode |
  223.     subMenuMode setUnclippedDisplayBoxOrigin: p.
  224.     "Check the boundary of the rootMode.  Shan July 25, 1989"
  225.     delta _ subMenuMode unclippedDisplayBox amountToTranslateWithin: subMenuMode topMode unclippedDisplayBox.
  226.     delta ~= (0 @ 0) ifTrue: [subMenuMode setUnclippedDisplayBoxOrigin: p + delta].
  227.     self storeSubMenuBackground.
  228.     subMenuMode mapAndDisplay.
  229.     enteredItemMode _ subMenuMode subModeContaining: self eventQueue mousePoint.
  230.     enteredItemMode notNil ifTrue: [enteredItemMode semanticObject cursorEnters: nil]!
  231.  
  232. formatSubMenu: bkMode 
  233.     "Shan July 26, 1989"
  234.  
  235.     | menuItemModes |
  236.     children isEmpty
  237.         ifFalse: 
  238.             [menuItemModes _ children collect: [:each | each mode].
  239.             subMenuMode _ Mode new borderWidth: 1.
  240.             ModeGrouper parent: subMenuMode verticalChildren: menuItemModes.
  241.             bkMode addSubMode: subMenuMode.
  242.             subMenuMode unMap.
  243.             children do: [:each | each formatSubMenu: bkMode]]!
  244.  
  245. shrinkSubMenus
  246.     "Recursively shrink the subMenu and subSubMenus.  Shan July 27,    
  247.     1989"
  248.  
  249.     children isEmpty
  250.         ifFalse: 
  251.             [children do: [:each | each shrinkSubMenus].
  252.             subMenuMode isVisible
  253.                 ifTrue: 
  254.                     [subMenuMode unMap.
  255.                     self restoreSubMenuBackground]].
  256.     "To componsate the case when the user activate a PersisMenu and 
  257.     then moves too fast from the subling mode that is first activated to 
  258.     this mode.  The subling mode has to have at least one cursorMove 
  259.     event in order to set the cursorIn and properly generate the 
  260.     leaveMode event.  This may not be true when the user moves fast.  
  261.     Shan July 30, 1989"
  262.     mode controller deHighlight! !
  263. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  264.  
  265. MenuCell class
  266.     instanceVariableNames: ''!
  267.  
  268.  
  269. !MenuCell class methodsFor: 'instance creation'!
  270.  
  271. selector: s
  272.     "Shan July 25, 1989"
  273.     ^self new selector: s!
  274.  
  275. selector: s text: aString 
  276.     "Shan July 25, 1989"
  277.  
  278.     ^self new selector: s text: aString! !
  279.  
  280. MenuCell subclass: #MMSMenu
  281.     instanceVariableNames: 'running '
  282.     classVariableNames: ''
  283.     poolDictionaries: ''
  284.     category: 'Menu-Shan'!
  285. MMSMenu comment:
  286. 'This is the root of the menu tree.  Shan July 30, 1989'!
  287.  
  288.  
  289. !MMSMenu methodsFor: 'controller-msg'!
  290.  
  291. terminate: e 
  292.     "Shan July 26, 1989"
  293.  
  294.     self shrinkSubMenus.
  295.     mode unMap.
  296.     "This prevents the menu from being garbage collected through the 
  297.     release of the rooMode.  Shan July 29, 1989"
  298.     mode removeFromSuperMode.
  299.     running _ false! !
  300.  
  301. !MMSMenu methodsFor: 'MMS-initializations'!
  302.  
  303. setUpAppearance
  304.     "Shan July 21, 1989"
  305.  
  306.     super setUpAppearance.
  307.     mode extent: Display boundingBox extent!
  308.  
  309. setUpController
  310.     "Override the controller definition in MenuCell.  Shan July 29, 1989"
  311.  
  312.     | ctrl erDict |
  313.     ctrl _ OpaqueController1 new.
  314.     mode controller: ctrl.
  315.     erDict _ ctrl eventResponses deepCopy.
  316.     erDict at: #leftButtonUp put: #terminate:.
  317.     erDict at: #middleButtonUp put: #terminate:.
  318.     erDict at: #rightButtonUp put: #terminate:.
  319.     ctrl eventResponses: erDict.! !
  320.  
  321. !MMSMenu methodsFor: 'formatting'!
  322.  
  323. formatSubMenu
  324.     "Shan July 29, 1989"
  325.  
  326.     subMenuMode isNil ifTrue: [self reformatSubMenu]!
  327.  
  328. formatTitlebarSubMenu: xDelta
  329.     "Shan July 29, 1989"
  330.  
  331.     subMenuMode isNil ifTrue: [self reformatTitlebarSubMenu: xDelta]!
  332.  
  333. reformatSubMenu
  334.     "Shan July 29, 1989"
  335.  
  336.     | menuItemModes |
  337.     children isEmpty
  338.         ifFalse: 
  339.             [menuItemModes _ children collect: [:each | each mode].
  340.             subMenuMode _ Mode new borderWidth: 1.
  341.             ModeGrouper parent: subMenuMode verticalChildren: menuItemModes.
  342.             mode addSubMode: subMenuMode.
  343.             subMenuMode unMap.
  344.             children do: [:each | each formatSubMenu: mode]]!
  345.  
  346. reformatTitlebarSubMenu: xDelta
  347.     "Shan July 29, 1989"
  348.  
  349.     | menuItemModes |
  350.     children isEmpty
  351.         ifFalse: 
  352.             [menuItemModes _ children collect: [:each | each mode].
  353.             "The only difference"
  354.             subMenuMode _ Mode new borderWidth: 1.
  355.             ModeGrouper parent: subMenuMode horizontalChildren: menuItemModes interval: xDelta.
  356.             mode addSubMode: subMenuMode.
  357.             subMenuMode unMap.
  358.             children do: [:each | each formatSubMenu: mode]]! !
  359.  
  360. !MMSMenu methodsFor: 'activation'!
  361.  
  362. activateOnRootMode: rootMode 
  363.     "Shan July 29, 1989"
  364.  
  365.     self activateOnRootMode: rootMode at: rootMode eventQueue mousePoint "Shan 13 July 1990"!
  366.  
  367. activateOnRootMode: rootMode at: origin 
  368.     "Shan July 29, 1989"
  369.  
  370.     | eq |
  371.     rootMode addSubMode: mode.
  372.     mode map.
  373.     self activateSubMenuAt: origin.
  374.     "The following is not necessary, but to keep the behavior of the menu 
  375.     consistent with the other implementations of menus.  Without it, the 
  376.     menu returns as soon as it is activated.  This may cause some 
  377.     confusion.  Add the loop so that the menu grab the control until the 
  378.     user selects something.  Shan July 31, 1989"
  379.     running _ true.
  380.     eq _ self eventQueue.  "Shan 13 July 1990"
  381.     [running]
  382.         whileTrue: [rootMode processEvent: eq nextWithCursorMoveCompressed
  383. "Shan 28 May 1990"]! !
  384.  
  385. SemanticObject subclass: #MenuTestWorkSpace
  386.     instanceVariableNames: ''
  387.     classVariableNames: 'ColorMapMenu LineWidthMenu TestWorkSpaceMiddleButtonMenu '
  388.     poolDictionaries: ''
  389.     category: 'Menu-Shan'!
  390.  
  391.  
  392. !MenuTestWorkSpace methodsFor: 'middleMenu support'!
  393.  
  394. end
  395.     Transcript show: ' end '!
  396.  
  397. one
  398.     Transcript show: ' one '.!
  399.  
  400. start
  401.     Transcript show: ' start '!
  402.  
  403. two
  404.     Transcript show: ' two '.! !
  405.  
  406. !MenuTestWorkSpace methodsFor: 'menu access'!
  407.  
  408. middleButtonMenu
  409.     "Shan July 25, 1989" 
  410.  
  411.     ^TestWorkSpaceMiddleButtonMenu!
  412.  
  413. middleButtonMenu: m 
  414.     "Shan July 25, 1989"
  415.  
  416.     TestWorkSpaceMiddleButtonMenu notNil ifTrue: [TestWorkSpaceMiddleButtonMenu release].
  417.     TestWorkSpaceMiddleButtonMenu _ m! !
  418.  
  419. !MenuTestWorkSpace methodsFor: 'controller-msg'!
  420.  
  421. expandMiddleMenu: e 
  422.     "Expand the MMS menu at the right place.  Shan July 25, 1989"
  423.  
  424.     self middleButtonMenu startUpOnSemanticObject: self! !
  425.  
  426. !MenuTestWorkSpace methodsFor: 'MMS-initializations'!
  427.  
  428. setUpController
  429.     "Shan July 25, 1989"
  430.  
  431.     | ctrl erDict |
  432.     super setUpController.
  433.     ctrl _ mode controller.
  434.     erDict _ ctrl eventResponses deepCopy.
  435.     erDict at: #middleButtonDown put: #expandMiddleMenu:.
  436.     ctrl eventResponses: erDict! !
  437. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  438.  
  439. MenuTestWorkSpace class
  440.     instanceVariableNames: ''!
  441.  
  442.  
  443. !MenuTestWorkSpace class methodsFor: 'memory management'!
  444.  
  445. private
  446.     "Shan July 28, 1989"
  447.     "MenuCell allInstances do: [: each | each nilFields]
  448.     Mode allInstances do: [: each | each nilFields]
  449.     MMSPopUpMenu allInstances do: [: each | each nilFields]"
  450.  
  451.     ^self! !
  452.  
  453. !MenuTestWorkSpace class methodsFor: 'access'!
  454.  
  455. colorMapLogicMenu
  456.     "Shan July 30, 1989"
  457.  
  458.     | logicM subM |
  459.     logicM _ MMSMenu new.
  460.     logicM append: (subM _ MenuCell selector: #white).
  461.     subM mode borderWidth: 1.
  462.     subM mode insideColor: Form white.
  463.     subM mode highlightDispObj: #thickBorderHighlight.
  464.     logicM append: (subM _ MenuCell selector: #veryLightGray).
  465.     subM mode borderWidth: 1.
  466.     subM mode insideColor: Form veryLightGray.
  467.     subM mode highlightDispObj: #thickBorderHighlight.
  468.     logicM append: (subM _ MenuCell selector: #lightGray).
  469.     subM mode borderWidth: 1.
  470.     subM mode insideColor: Form lightGray.
  471.     subM mode highlightDispObj: #thickBorderHighlight.
  472.     logicM append: (subM _ MenuCell selector: #gray).
  473.     subM mode borderWidth: 1.
  474.     subM mode insideColor: Form gray.
  475.     subM mode highlightDispObj: #thickBorderHighlight.
  476.     logicM append: (subM _ MenuCell selector: #darkGray).
  477.     subM mode borderWidth: 1.
  478.     subM mode insideColor: Form darkGray.
  479.     subM mode highlightDispObj: #thickBorderHighlight.
  480.     logicM append: (subM _ MenuCell selector: #veryDarkGray).
  481.     subM mode borderWidth: 1.
  482.     subM mode insideColor: Form veryDarkGray.
  483.     subM mode highlightDispObj: #thickBorderHighlight.
  484.     logicM append: (subM _ MenuCell selector: #black).
  485.     subM mode borderWidth: 1.
  486.     subM mode borderColor: Form white.
  487.     subM mode insideColor: Form black.
  488.     subM mode highlightDispObj: #thickBorderHighlight.
  489.     logicM append: (MenuCell selector: #transparent text: 'Transparent').
  490.     ^logicM!
  491.  
  492. colorMapMenu
  493.     "Shan July 31, 1989"
  494.  
  495.     ColorMapMenu isNil ifTrue: [ColorMapMenu _ MMSPopUpMenu createInterfaceFor: self colorMapLogicMenu].
  496.     ^ColorMapMenu!
  497.  
  498. lineWidthLogicMenu
  499.     "Shan July 30, 1989"
  500.  
  501.     | logicM subM |
  502.     logicM _ MMSMenu new.
  503.     logicM append: (subM _ MenuCell selector: #zero text: 'Width 0').
  504.     subM mode borderWidth: 1.
  505.     subM mode insideColor: Form white.
  506.     logicM append: (subM _ MenuCell selector: #one).
  507.     subM mode borderWidth: 1.
  508.     subM mode insideColor: Form white.
  509.     subM mode displayObject relAdd: (MMSLine from: 5@6 to: 50@6 width: 1 color: Form black).
  510.     subM mode extent: 60@15.
  511.     logicM append: (subM _ MenuCell selector: #two).
  512.     subM mode borderWidth: 1.
  513.     subM mode insideColor: Form white.
  514.     subM mode displayObject relAdd: (MMSLine from: 5@6 to: 50@6 width: 2 color: Form black).
  515.     subM mode extent: 60@15.
  516.     logicM append: (subM _ MenuCell selector: #three).
  517.     subM mode borderWidth: 1.
  518.     subM mode insideColor: Form white.
  519.     subM mode displayObject relAdd: (MMSLine from: 5@6 to: 50@6 width: 3 color: Form black).
  520.     subM mode extent: 60@16.
  521.     logicM append: (subM _ MenuCell selector: #four).
  522.     subM mode borderWidth: 1.
  523.     subM mode insideColor: Form white.
  524.     subM mode displayObject relAdd: (MMSLine from: 5@6 to: 50@6 width: 4 color: Form black).
  525.     subM mode extent: 60@17.
  526.     ^logicM!
  527.  
  528. lineWidthMenu
  529.     "Shan July 31, 1989"
  530.  
  531.     LineWidthMenu isNil ifTrue: [LineWidthMenu _ MMSPopUpMenu createInterfaceFor: self lineWidthLogicMenu].
  532.     ^LineWidthMenu! !
  533.  
  534. !MenuTestWorkSpace class methodsFor: 'test'!
  535.  
  536. menuTest
  537.     "(RootMode new addSubMode: self menuTest) startUp"
  538.     "Shan August 27, 1989"
  539.  
  540.     | tws menu logicMenu |
  541.     tws _ self new.
  542.     logicMenu _ self testLogicMenu.
  543.     menu _ MMSPopUpMenu createInterfaceFor: logicMenu.
  544.     tws middleButtonMenu: menu.
  545.     menu _ MMSPersisMenu createInterfaceFor: logicMenu startUpSelector: #middleButtonDown.
  546.     menu moveSelector: #leftButtonDown.
  547.     menu attachTo: tws mode at: 5@40.
  548.     menu receiver: tws.
  549.     "Here I need a new menu because the first level looks different."
  550.     menu _ MMSTitlebarMenu createInterfaceFor: self testLogicMenu interval: 20.
  551.     menu attachTo: tws mode at: 2@2.
  552.     menu receiver: tws.
  553.     ^tws mode resizeStyle: ResizeStyle stickFourCorners!
  554.  
  555. testLogicMenu
  556.     "Shan August 27, 1989"
  557.  
  558.     | logicMenu  subM sSubM ssSubM dispObj |
  559.     "Construct the logical menu."
  560.     logicMenu _ MMSMenu new.
  561.     logicMenu append: (MenuCell selector: #start text: 'File').
  562.     logicMenu append: (subM _ MenuCell selector: nil text: 'Hierarchy').
  563.     subM append: (MenuCell selector: #one text: 'One').
  564.     subM append: (sSubM _ MenuCell selector: #two text: 'Two again').
  565.     sSubM append: (MenuCell selector: #one text: 'One').
  566.     sSubM append: (MenuCell selector: #two text: 'Two').
  567.     logicMenu append: (subM _ MenuCell selector: #end text: 'Languages').
  568.     subM append: (sSubM _ MenuCell selector: #end).
  569.     sSubM mode displayObject relAdd: MMSOpaqueForm chinese.
  570.     sSubM mode resizeToFitDisplayObject.
  571.     subM append: (sSubM _ MenuCell selector: #end).
  572.     sSubM mode displayObject relAdd: MMSOpaqueForm japanese.
  573.     sSubM mode resizeToFitDisplayObject.
  574.     subM append: (sSubM _ MenuCell selector: #end).
  575.     sSubM mode displayObject relAdd: MMSOpaqueForm good.
  576.     sSubM mode displayObject relAdd: ('Good in\Chinese' withCRs asDisplayText offset: 30@0).
  577.     sSubM mode resizeToFitDisplayObjectBy: 15@0.
  578.     logicMenu append: (subM _ MenuCell selector: nil text: 'Trash').
  579.     subM append: (MenuCell selector: #end text: 'No oop').
  580.     subM append: (sSubM _ MenuCell selector: #end).
  581.     sSubM mode displayObject relAdd: MMSOpaqueForm trash.
  582.     sSubM mode highlightDispObj: (MDisplayObject new relAdd: MMSOpaqueForm openTrash).
  583.     sSubM mode resizeToFitDisplayObject.
  584.     sSubM append: (MenuCell selector: #end text: 'What a Menu').
  585.     sSubM append: (MenuCell selector: #end text: 'What a Trash').
  586.     sSubM append: (ssSubM _ MenuCell selector: #end).
  587.     ssSubM mode displayObject relAdd: MMSOpaqueForm oddShape.
  588.     ssSubM mode resizeToFitDisplayObject.
  589.     subM append: (sSubM _ MenuCell selector: #end text: 'Surprise').
  590.     sSubM mode highlightDispObj: (dispObj _MDisplayObject new insideColor: Form white).
  591.     dispObj relAdd: ('I''ve changed!!' asParagraph offset: 2@0).
  592.     sSubM mode resizeToFitDisplayObject.
  593.     "dispObj inverse: sSubM mode extent + (2@0).  dispObj display."
  594.     sSubM append: (ssSubM _ MenuCell selector: #end).
  595.     ssSubM mode borderWidth: 1.
  596.     ssSubM mode insideColor: Form white.
  597.     ssSubM mode highlightDispObj: #thickBorderHighlight.
  598.     sSubM append: (ssSubM _ MenuCell selector: #end).
  599.     ssSubM mode borderWidth: 1.
  600.     ssSubM mode insideColor: Form veryLightGray.
  601.     ssSubM mode highlightDispObj: #thickBorderHighlight.
  602.     sSubM append: (ssSubM _ MenuCell selector: #end).
  603.     ssSubM mode borderWidth: 1.
  604.     ssSubM mode insideColor: Form lightGray.
  605.     ssSubM mode highlightDispObj: #thickBorderHighlight.
  606.     sSubM append: (ssSubM _ MenuCell selector: #end text: 'This is\also a\menu' withCRs).
  607.     ssSubM mode highlightDispObj: (AnimationDispObj rotatingStar).
  608.     ^logicMenu! !
  609.  
  610. OpaqueController1 subclass: #MenuCellController
  611.     instanceVariableNames: ''
  612.     classVariableNames: 'MenuCellControllerERD '
  613.     poolDictionaries: ''
  614.     category: 'Menu-Shan'!
  615.  
  616. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  617.  
  618. MenuCellController class
  619.     instanceVariableNames: ''!
  620.  
  621.  
  622. !MenuCellController class methodsFor: 'initialize'!
  623.  
  624. ERDinit
  625.     "Shan July 29, 1989"
  626.  
  627.     MenuCellControllerERD _ super eventResponsesDict deepCopy.
  628.     "Enable the menu to use either one of the three buttons."
  629.     MenuCellControllerERD at: #leftButtonUp put: #action:.
  630.     MenuCellControllerERD at: #middleButtonUp put: #action:.
  631.     MenuCellControllerERD at: #rightButtonUp put: #action:.
  632.     MenuCellControllerERD at: #enterMode put: #cursorEnters:.
  633.     MenuCellControllerERD at: #leaveMode put: #cursorLeaves:! !
  634.  
  635. !MenuCellController class methodsFor: 'access'!
  636.  
  637. eventResponsesDict
  638.     ^ MenuCellControllerERD! !
  639.  
  640. SemanticObject subclass: #ModeGrouper
  641.     instanceVariableNames: ''
  642.     classVariableNames: ''
  643.     poolDictionaries: ''
  644.     category: 'Menu-Shan'!
  645. ModeGrouper comment:
  646. 'This class provide the ability to format a composit mode out of a collection of mode.   Shan July 25, 1989'!
  647.  
  648. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  649.  
  650. ModeGrouper class
  651.     instanceVariableNames: ''!
  652.  
  653.  
  654. !ModeGrouper class methodsFor: 'services'!
  655.  
  656. parent: superMode centerVerticalChildren: aCollectionOfModes
  657.     "Create a vertical mode group (which is a mode it self) that contains 
  658.     the modes in the aCollectionOfModes with no interval between each of 
  659.     them.  The modes are center aligned.  Shan July 31, 1989"
  660.  
  661.     ^self parent: superMode centerVerticalChildren: aCollectionOfModes interval: 0!
  662.  
  663. parent: superMode centerVerticalChildren: aCollectionOfModes interval: yDelta 
  664.     "Create a vertical mode group (which is a mode it self) that contains  
  665.     the modes in the aCollectionOfModes with int interval between each 
  666.     of them.  The modes are center aligned.  Shan July 31, 1989"
  667.  
  668.     | maxWidth height offset |
  669.     maxWidth _ 0.
  670.     aCollectionOfModes do: [:each | each viewport width > maxWidth ifTrue: [maxWidth _ each viewport width]].
  671.     maxWidth _ maxWidth + (2 * superMode borderWidth).
  672.     height _ superMode borderWidth + yDelta.
  673.     aCollectionOfModes do: 
  674.         [:each | 
  675.         offset _ maxWidth - each viewport width / 2.
  676.         superMode addSubMode: each at: offset @ height.
  677.         height _ height + each viewport height + yDelta].
  678.     superMode extent: maxWidth + (2 * superMode borderWidth) @ (height + superMode borderWidth).
  679.     ^superMode!
  680.  
  681. parent: superMode horizontalChildren: aCollectionOfModes 
  682.     "Create a mode group (which is a mode it self) that contains the 
  683.     modes in the aCollectionOfModes.  Shan July 25, 1989"
  684.  
  685.     ^self parent: superMode horizontalChildren: aCollectionOfModes interval: 0!
  686.  
  687. parent: superMode horizontalChildren: aCollectionOfModes interval: xDelta 
  688.     "Create a horizontal mode group (which is a mode it self) that 
  689.     contains the modes in the aCollectionOfModes with int interval 
  690.     between each of them.  Shan July 25, 1989"
  691.  
  692.     | maxHeight width |
  693.     maxHeight _ 0.
  694.     aCollectionOfModes do: [:each | each viewport height > maxHeight ifTrue: [maxHeight _ each viewport height]].
  695.     maxHeight _ maxHeight + (2 * superMode borderWidth).
  696.     width _ superMode borderWidth + xDelta.
  697.     aCollectionOfModes do: 
  698.         [:each | 
  699.         superMode addSubMode: each at: width @ superMode borderWidth.
  700.         width _ width + each viewport width + xDelta.
  701.         each height: maxHeight].
  702.     superMode extent: width + superMode borderWidth @ maxHeight + (2 * superMode borderWidth).
  703.     ^superMode!
  704.  
  705. parent: superMode verticalChildren: aCollectionOfModes 
  706.     "Create a mode group (which is a mode it self) that contains the 
  707.     modes in the aCollectionOfModes.  Shan July 25, 1989"
  708.  
  709.     ^self parent: superMode verticalChildren: aCollectionOfModes interval: 0!
  710.  
  711. parent: superMode verticalChildren: aCollectionOfModes interval: yDelta 
  712.     "Create a vertical mode group (which is a mode it self) that contains 
  713.     the modes in the aCollectionOfModes with int interval between each of 
  714.     them.  Shan July 25, 1989"
  715.  
  716.     | maxWidth height |
  717.     maxWidth _ 0.
  718.     aCollectionOfModes do: [:each | each viewport width > maxWidth ifTrue: [maxWidth _ each viewport width]].
  719.     maxWidth _ maxWidth + (2 * superMode borderWidth).
  720.     height _ superMode borderWidth + yDelta.
  721.     aCollectionOfModes do: 
  722.         [:each | 
  723.         superMode addSubMode: each at: superMode borderWidth @ height.
  724.         height _ height + each viewport height + yDelta.
  725.         each width: maxWidth].
  726.     superMode extent: maxWidth + (2 * superMode borderWidth) @ (height + superMode borderWidth).
  727.     ^superMode! !
  728.  
  729. Object subclass: #MMSPopUpMenu
  730.     instanceVariableNames: 'menu '
  731.     classVariableNames: ''
  732.     poolDictionaries: ''
  733.     category: 'Menu-Shan'!
  734. MMSPopUpMenu comment:
  735. 'Physical menu.  Shan July 25, 1989'!
  736.  
  737.  
  738. !MMSPopUpMenu methodsFor: 'private'!
  739.  
  740. createInterfaceFor: aMenuCellTree 
  741.     "Take a tree of MenuCells and format them into a hierarhical pop up   
  742.      menu.  Shan July 25, 1989"
  743.  
  744.     menu _ aMenuCellTree.
  745.     menu formatSubMenu! !
  746.  
  747. !MMSPopUpMenu methodsFor: 'activation'!
  748.  
  749. startUpOn: aReceiver rootMode: rMode
  750.     "Caller must provide the rootMode.  Shan July 30, 1989"
  751.  
  752.     menu receiver: aReceiver.
  753.     menu activateOnRootMode: rMode!
  754.  
  755. startUpOnSemanticObject: aReceiver 
  756.     "Receiver must be a semantic object.  Shan July 25, 1989"
  757.  
  758.     menu receiver: aReceiver.
  759.     menu activateOnRootMode: aReceiver mode topMode! !
  760.  
  761. !MMSPopUpMenu methodsFor: 'initialize-release'!
  762.  
  763. release
  764.     "Shan July 29, 1989"
  765.  
  766.     menu notNil ifTrue: [menu mode release].
  767.     super release! !
  768. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  769.  
  770. MMSPopUpMenu class
  771.     instanceVariableNames: ''!
  772.  
  773.  
  774. !MMSPopUpMenu class methodsFor: 'instance creation'!
  775.  
  776. createInterfaceFor: aTreeOfMenuCell 
  777.     "Take a tree of MenuCell and create a PopUpMenu.  Shan July 30,  
  778.     1989"
  779.  
  780.     ^self new createInterfaceFor: aTreeOfMenuCell! !
  781.  
  782. MMSPopUpMenu subclass: #MMSPersisMenu
  783.     instanceVariableNames: 'menuProxy receiver startUpSelector moveSelector '
  784.     classVariableNames: ''
  785.     poolDictionaries: ''
  786.     category: 'Menu-Shan'!
  787.  
  788.  
  789. !MMSPersisMenu methodsFor: 'attach'!
  790.  
  791. attachTo: envMode at: origin 
  792.     "This time the menuProxy is attached.  Not my mode.  Shan July 29, 
  793.     1989 "
  794.  
  795.     envMode addSubMode: menuProxy mode at: origin! !
  796.  
  797. !MMSPersisMenu methodsFor: 'private'!
  798.  
  799. createInterfaceFor: aMenuCellTree startUpSelector: aSymbol
  800.     "Take a tree of MenuCells and format them into a hierarhical persistent   
  801.     menu.  Shan July 25, 1989"
  802.  
  803.     menu _ aMenuCellTree.
  804.     startUpSelector _ aSymbol.
  805.     menu formatSubMenu.
  806.     menuProxy _ MenuProxy client: self! !
  807.  
  808. !MMSPersisMenu methodsFor: 'access'!
  809.  
  810. image
  811.     "Shan July 29, 1989"
  812.  
  813.     ^menu subMenuMode image!
  814.  
  815. moveSelector
  816.     "Persistent menus some times can be moved.  Shan August 27, 1989"
  817.  
  818.     ^moveSelector!
  819.  
  820. moveSelector: aSymbol
  821.     "Persistent menus some times can be moved.  Shan August 27, 1989"
  822.  
  823.     moveSelector _ aSymbol!
  824.  
  825. receiver
  826.     "Shan July 29, 1989"
  827.  
  828.     ^receiver!
  829.  
  830. receiver: anObj
  831.     "Shan July 29, 1989"
  832.  
  833.     receiver _ anObj!
  834.  
  835. startUpSelector
  836.     "Shan July 30, 1989"
  837.  
  838.     ^startUpSelector!
  839.  
  840. startUpSelector: aSymbol
  841.     "Shan July 30, 1989"
  842.  
  843.     startUpSelector _ aSymbol! !
  844.  
  845. !MMSPersisMenu methodsFor: 'activation'!
  846.  
  847. startUpAt: origin rootMode: rootMode 
  848.     "The origin is from the proxy.  Shan July 29, 1989"
  849.  
  850.     menu receiver: receiver.
  851.     "The menu can be used by many physical menus."
  852.     menu activateOnRootMode: rootMode at: origin! !
  853. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  854.  
  855. MMSPersisMenu class
  856.     instanceVariableNames: ''!
  857.  
  858.  
  859. !MMSPersisMenu class methodsFor: 'instance creation'!
  860.  
  861. createInterfaceFor: aTreeOfMenuCell 
  862.     "Shan  July 30, 1989"
  863.  
  864.     ^self createInterfaceFor: aTreeOfMenuCell startUpSelector: #middleButtonDown!
  865.  
  866. createInterfaceFor: aTreeOfMenuCell startUpSelector: aSymbol 
  867.     "Take a tree of MenuCell and create a PopUpMenu.  aSymbol can be  
  868.     #leftButtonDown #middleButtonDown or #rightButtonDown.  Shan 
  869.     July 30, 1989"
  870.  
  871.     ^self new createInterfaceFor: aTreeOfMenuCell startUpSelector: aSymbol! !
  872.  
  873. MMSPersisMenu subclass: #MMSTitlebarMenu
  874.     instanceVariableNames: ''
  875.     classVariableNames: ''
  876.     poolDictionaries: ''
  877.     category: 'Menu-Shan'!
  878.  
  879.  
  880. !MMSTitlebarMenu methodsFor: 'private'!
  881.  
  882. createInterfaceFor: aMenuCellTree interval: xDelta startUpSelector: aSymbol
  883.     "Take a tree of MenuCells and format them into a hierarhical persistent   
  884.     menu.  Shan July 30, 1989"
  885.  
  886.     menu _ aMenuCellTree.
  887.     startUpSelector _ aSymbol.
  888.     menu formatTitlebarSubMenu: xDelta.
  889.     menu children do: [:each | each activatingDirection: #down].
  890.     menuProxy _ MenuProxy client: self! !
  891. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  892.  
  893. MMSTitlebarMenu class
  894.     instanceVariableNames: ''!
  895.  
  896.  
  897. !MMSTitlebarMenu class methodsFor: 'instance creation'!
  898.  
  899. createInterfaceFor: aTreeOfMenuCell interval: xDelta
  900.     "Take a tree of MenuCell and create a titlebar menu.  Shan July 29, 
  901.     1989 "
  902.  
  903.     ^self createInterfaceFor: aTreeOfMenuCell interval: xDelta startUpSelector: #middleButtonDown!
  904.  
  905. createInterfaceFor: aTreeOfMenuCell interval: xDelta startUpSelector: aSymbol
  906.     "Take a tree of MenuCell and create a titlebar menu.  Shan July 30, 
  907.     1989 "
  908.  
  909.     ^self new createInterfaceFor: aTreeOfMenuCell interval: xDelta startUpSelector: aSymbol! !
  910.  
  911. SemanticObject subclass: #MenuProxy
  912.     instanceVariableNames: 'client '
  913.     classVariableNames: ''
  914.     poolDictionaries: ''
  915.     category: 'Menu-Shan'!
  916. MenuProxy comment:
  917. 'This is specifically for the Persistent menus.  The mode represents the menu in the windowing env.  When a button is pressed within the boundary of the mode, it activates the real menu.  Shan July 29, 1989'!
  918.  
  919.  
  920. !MenuProxy methodsFor: 'private'!
  921.  
  922. client: aPersisMenu
  923.     "Shan July 29, 1989"
  924.     client _ aPersisMenu.
  925.     mode displayObject relAdd: (client image).
  926.     mode resizeToFitDisplayObject.! !
  927.  
  928. !MenuProxy methodsFor: 'controller-msg'!
  929.  
  930. activateClient: e 
  931.     "client is a pop up menu.  Activate it.  Shan July 29, 1989"
  932.  
  933.     e selector = client startUpSelector ifTrue: [client startUpAt: mode unclippedDisplayBox origin rootMode: mode topMode].
  934.     e selector = client moveSelector ifTrue: [mode controller moveImage]! !
  935.  
  936. !MenuProxy methodsFor: 'MMS-initializations'!
  937.  
  938. setUpController
  939.     "Shan July 29, 1989"
  940.  
  941.     | ctrl erDict |
  942.     super setUpController.
  943.     ctrl _ mode controller.
  944.     erDict _ ctrl eventResponses deepCopy.
  945.     erDict at: #leftButtonDown put: #activateClient:.
  946.     erDict at: #middleButtonDown put: #activateClient:.
  947.     erDict at: #rightButtonDown put: #activateClient:.
  948.     ctrl eventResponses: erDict.! !
  949.  
  950. !MenuProxy methodsFor: 'initialize-release'!
  951.  
  952. release
  953.     "Shan July 29, 1989"
  954.  
  955.     client release.
  956.     "Different title bar menus out of the same logic menu may have 
  957.     different interval.  This will cause problems.  At this stage, each title 
  958.     bar menu must have its own logic menu.  If later we wish to share 
  959.     the logic menu, the 'client release' will need to be removed.  Shan 
  960.     July 30, 1989"
  961.     super release! !
  962. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  963.  
  964. MenuProxy class
  965.     instanceVariableNames: ''!
  966.  
  967.  
  968. !MenuProxy class methodsFor: 'instance creation'!
  969.  
  970. client: aPersisMenu 
  971.     "Shan July 29, 1989"
  972.  
  973.     ^self new client: aPersisMenu! !